home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-9.10-netbook-remix-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / Debconf / Template.pm < prev    next >
Text File  |  2009-10-02  |  8KB  |  345 lines
  1. #!/usr/bin/perl -w
  2. # This file was preprocessed, do not edit!
  3.  
  4.  
  5. package Debconf::Template;
  6. use strict;
  7. use POSIX;
  8. use FileHandle;
  9. use Debconf::Gettext;
  10. use Text::Wrap;
  11. use Text::Tabs;
  12. use Debconf::Db;
  13. use Debconf::Iterator;
  14. use Debconf::Question;
  15. use fields qw(template);
  16. use Debconf::Log q{:all};
  17. use Debconf::Encoding;
  18. use Debconf::Config;
  19.  
  20. our %template;
  21. $Debconf::Template::i18n=1;
  22.  
  23. our %known_field = map { $_ => 1 }
  24.     qw{template description choices default type};
  25.  
  26. binmode(STDOUT);
  27. binmode(STDERR);
  28.     
  29.  
  30.  
  31. sub new {
  32.     my Debconf::Template $this=shift;
  33.     my $template=shift || die "no template name specified";
  34.     my $owner=shift || 'unknown';
  35.     my $type=shift || die "no template type specified";
  36.     
  37.     if ($Debconf::Db::templates->exists($template) and
  38.         $Debconf::Db::templates->owners($template)) {
  39.         my $q=Debconf::Question->get($template);
  40.         $q->addowner($owner, $type) if $q;
  41.  
  42.         my @owners=$Debconf::Db::templates->owners($template);
  43.         foreach my $question (@owners) {
  44.             my $q=Debconf::Question->get($question);
  45.             if (! $q) {
  46.                 warn sprintf(gettext("warning: possible database corruption. Will attempt to repair by adding back missing question %s."), $question);
  47.                 my $newq=Debconf::Question->new($question, $owner, $type);
  48.                 $newq->template($template);
  49.             }
  50.         }
  51.         
  52.         $this = fields::new($this);
  53.         $this->{template}=$template;
  54.         return $template{$template}=$this;
  55.     }
  56.  
  57.     unless (ref $this) {
  58.         $this = fields::new($this);
  59.     }
  60.     $this->{template}=$template;
  61.  
  62.     if ($Debconf::Db::config->exists($template)) {
  63.         my $q=Debconf::Question->get($template);
  64.         $q->addowner($owner, $type) if $q;
  65.     }
  66.     else {
  67.         my $q=Debconf::Question->new($template, $owner, $type);
  68.         $q->template($template);
  69.     }
  70.     
  71.     return unless $Debconf::Db::templates->addowner($template, $template, $type);
  72.  
  73.     $Debconf::Db::templates->setfield($template, 'type', $type);
  74.     return $template{$template}=$this;
  75. }
  76.  
  77.  
  78. sub get {
  79.     my Debconf::Template $this=shift;
  80.     my $template=shift;
  81.     return $template{$template} if exists $template{$template};
  82.     if ($Debconf::Db::templates->exists($template)) {
  83.         $this = fields::new($this);
  84.         $this->{template}=$template;
  85.         return $template{$template}=$this;
  86.     }
  87.     return undef;
  88. }
  89.  
  90.  
  91. sub i18n {
  92.     my $class=shift;
  93.     $Debconf::Template::i18n=shift;
  94. }
  95.  
  96.  
  97. sub load {
  98.     my $this=shift;
  99.     my $file=shift;
  100.  
  101.     my @ret;
  102.     my $fh;
  103.  
  104.     if (ref $file) {
  105.         $fh=$file;
  106.     }
  107.     else {
  108.         $fh=FileHandle->new($file) || die "$file: $!";
  109.     }
  110.     local $/="\n\n"; # read a template at a time.
  111.     while (<$fh>) {
  112.         my %data;
  113.         
  114.         my $save = sub {
  115.             my $field=shift;
  116.             my $value=shift;
  117.             my $extended=shift;
  118.             my $file=shift;
  119.  
  120.             $extended=~s/\n+$//;
  121.  
  122.             if ($field ne '') {
  123.                 if (exists $data{$field}) {
  124.                     die sprintf(gettext("Template #%s in %s has a duplicate field \"%s\" with new value \"%s\". Probably two templates are not properly separated by a lone newline.\n"), $., $file, $field, $value);
  125.                 }
  126.                 $data{$field}=$value;
  127.                 $data{"extended_$field"}=$extended
  128.                     if length $extended;
  129.             }
  130.         };
  131.  
  132.         s/^\n+//;
  133.         s/\n+$//;
  134.         my ($field, $value, $extended)=('', '', '');
  135.         foreach my $line (split "\n", $_) {
  136.             chomp $line;
  137.             if ($line=~/^([-_.A-Za-z0-9]*):\s?(.*)/) {
  138.                 $save->($field, $value, $extended, $file);
  139.                 $field=lc $1;
  140.                 $value=$2;
  141.                 $value=~s/\s*$//;
  142.                 $extended='';
  143.                 my $basefield=$field;
  144.                 $basefield=~s/-.+$//;
  145.                 if (! $known_field{$basefield}) {
  146.                     warn sprintf(gettext("Unknown template field '%s', in stanza #%s of %s\n"), $field, $., $file);
  147.                 }
  148.             }
  149.             elsif ($line=~/^\s\.$/) {
  150.                 $extended.="\n\n";
  151.             }
  152.             elsif ($line=~/^\s(\s+.*)/) {
  153.                 my $bit=$1;
  154.                 $bit=~s/\s*$//;
  155.                 $extended.="\n" if length $extended &&
  156.                                    $extended !~ /[\n ]$/;
  157.                 $extended.=$bit."\n";
  158.             }
  159.             elsif ($line=~/^\s(.*)/) {
  160.                 my $bit=$1;
  161.                 $bit=~s/\s*$//;
  162.                 $extended.=' ' if length $extended &&
  163.                                   $extended !~ /[\n ]$/;
  164.                 $extended.=$bit;
  165.             }
  166.             else {
  167.                 die sprintf(gettext("Template parse error near `%s', in stanza #%s of %s\n"), $line, $., $file);
  168.             }
  169.         }
  170.         $save->($field, $value, $extended, $file);
  171.  
  172.         die sprintf(gettext("Template #%s in %s does not contain a 'Template:' line\n"), $., $file)
  173.             unless $data{template};
  174.  
  175.         my $template=$this->new($data{template}, @_, $data{type});
  176.         $template->clearall;
  177.         foreach my $key (keys %data) {
  178.             next if $key eq 'template';
  179.             $template->$key($data{$key});
  180.         }
  181.         push @ret, $template;
  182.     }
  183.  
  184.     return @ret;
  185. }
  186.                     
  187.  
  188. sub template {
  189.     my $this=shift;
  190.  
  191.     return $this->{template};
  192. }
  193.  
  194.  
  195. sub fields {
  196.     my $this=shift;
  197.  
  198.     return $Debconf::Db::templates->fields($this->{template});
  199. }
  200.  
  201.  
  202. sub clearall {
  203.     my $this=shift;
  204.  
  205.     foreach my $field ($this->fields) {
  206.         $Debconf::Db::templates->removefield($this->{template}, $field);
  207.     }
  208. }
  209.  
  210.  
  211. sub stringify {
  212.     my $this=shift;
  213.  
  214.     my @templatestrings;
  215.     foreach (ref $this ? $this : @_) {
  216.         my $data='';
  217.         foreach my $key ('template', 'type',
  218.             (grep { $_ ne 'template' && $_ ne 'type'} sort $_->fields)) {
  219.             next if $key=~/^extended_/;
  220.             if ($key =~ m/-[a-z]{2}_[a-z]{2}(-fuzzy)?$/) {
  221.                 my $casekey=$key;
  222.                 $casekey=~s/([a-z]{2})(-fuzzy|)$/uc($1).$2/eg;
  223.                 $data.=ucfirst($casekey).": ".$_->$key."\n";
  224.             }
  225.             else {
  226.                 $data.=ucfirst($key).": ".$_->$key."\n";
  227.             }
  228.             my $e="extended_$key";
  229.             my $ext=$_->$e;
  230.             if (defined $ext) {
  231.                 $Text::Wrap::break = qr/\n|\s(?=\S)/;
  232.                 my $extended=expand(wrap(' ', ' ', $ext));
  233.                 $extended=~s/(\n )+\n/\n .\n/g;
  234.                 $data.=$extended."\n" if length $extended;
  235.             }
  236.         }
  237.         push @templatestrings, $data;
  238.     }
  239.     return join("\n", @templatestrings);
  240. }
  241.  
  242.  
  243. sub _addterritory {
  244.     my $locale=shift;
  245.     my $territory=shift;
  246.     $locale=~s/^([^_@.]+)/$1$territory/;
  247.     return $locale;
  248. }
  249. sub _addcharset {
  250.     my $locale=shift;
  251.     my $charset=shift;
  252.     $locale=~s/^([^@.]+)/$1$charset/;
  253.     return $locale;
  254. }
  255. sub _getlocalelist {
  256.     my $locale=shift;
  257.     $locale=~s/(@[^.]+)//;
  258.     my $modifier=$1;
  259.     my ($lang, $territory, $charset)=($locale=~m/^
  260.          ([^_@.]+)      #  Language
  261.          (_[^_@.]+)?    #  Territory
  262.          (\..+)?        #  Charset
  263.          /x);
  264.     my (@ret) = ($lang);
  265.     @ret = map { $_.$modifier, $_} @ret if defined $modifier;
  266.     @ret = map { _addterritory($_,$territory), $_} @ret if defined $territory;
  267.     @ret = map { _addcharset($_,$charset), $_} @ret if defined $charset;
  268.     return @ret;
  269. }
  270.  
  271. sub _getlangs {
  272.     my $language=setlocale(5); # LC_MESSAGES
  273.     my @langs = ();
  274.     if (exists $ENV{LANGUAGE} && $ENV{LANGUAGE} ne '') {
  275.         foreach (split(/:/, $ENV{LANGUAGE})) {
  276.             push (@langs, _getlocalelist($_));
  277.         }
  278.     }
  279.     return @langs, _getlocalelist($language);
  280. }
  281.  
  282. my @langs=map { lc $_ } _getlangs();
  283.  
  284. sub AUTOLOAD {
  285.     (my $field = our $AUTOLOAD) =~ s/.*://;
  286.     no strict 'refs';
  287.     *$AUTOLOAD = sub {
  288.         my $this=shift;
  289.         if (@_) {
  290.             return $Debconf::Db::templates->setfield($this->{template}, $field, shift);
  291.         }
  292.         
  293.         my $ret;
  294.         my $want_i18n = $Debconf::Template::i18n && Debconf::Config->c_values ne 'true';
  295.  
  296.         if ($want_i18n && @langs) {
  297.             foreach my $lang (@langs) {
  298.                 $lang = 'en' if $lang eq 'c';
  299.  
  300.                 $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-'.$lang);
  301.                 return $ret if defined $ret;
  302.                 
  303.                 if ($Debconf::Encoding::charmap) {
  304.                     foreach my $f ($Debconf::Db::templates->fields($this->{template})) {
  305.                         if ($f =~ /^\Q$field-$lang\E\.(.+)/) {
  306.                             my $encoding = $1;
  307.                             $ret = Debconf::Encoding::convert($encoding, $Debconf::Db::templates->getfield($this->{template}, lc($f)));
  308.                             return $ret if defined $ret;
  309.                         }
  310.                     }
  311.                 }
  312.  
  313.                 last if $lang eq 'en';
  314.             }
  315.         } elsif (not $want_i18n && $field !~ /-c$/i) {
  316.             $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-c');
  317.             return $ret if defined $ret;
  318.         }
  319.  
  320.         $ret=$Debconf::Db::templates->getfield($this->{template}, $field);
  321.         return $ret if defined $ret;
  322.  
  323.         if ($field =~ /-/) {
  324.             (my $plainfield = $field) =~ s/-.*//;
  325.             $ret=$Debconf::Db::templates->getfield($this->{template}, $plainfield);
  326.             return $ret if defined $ret;
  327.             return '';
  328.         }
  329.  
  330.         return '';
  331.     };
  332.     goto &$AUTOLOAD;
  333. }
  334.  
  335. sub DESTROY {}
  336.  
  337. use overload
  338.     '""' => sub {
  339.         my $template=shift;
  340.         $template->template;
  341.     };
  342.  
  343.  
  344. 1
  345.